home *** CD-ROM | disk | FTP | other *** search
/ Experimental BBS Explossion 3 / Experimental BBS Explossion III.iso / pascal / dlgdsn41.zip / PASSRC1.PAS < prev    next >
Pascal/Delphi Source File  |  1994-01-02  |  15KB  |  576 lines
  1. {$A-,B-,E+,F-,G-,I+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
  2. {$M 16384,5000,655360}
  3.  
  4. Program PasSrc1;
  5.  
  6. uses Dos, Objects, {Drivers, Views, Dialogs,
  7.      Editors, Validate,} Dialogs, ReadScpt;
  8.  
  9. const
  10. (*  dpBlueDialog = 0;
  11.   dpCyanDialog = 1;
  12.   dpGrayDialog = 2;  *)
  13.  
  14.   NeedControl1 : boolean = False;
  15. var
  16.   P : PScriptRec;
  17.   Outf : Text;
  18.   DlgName : string[50];  {holds dialog's variable name for easy reference}
  19.  
  20. function Positn(Pat, Src : String; I : Integer) : Integer;
  21. {find the position of a substring in a string starting at the Ith char}
  22. var
  23.   N : Integer;
  24. begin
  25. if I < 1 then I := 1;
  26. Delete(Src, 1, I-1);
  27. N := Pos(Pat, Src);
  28. if N = 0 then Positn := 0
  29.   else Positn := N+I-1;
  30. end;
  31.  
  32. FUNCTION Quoted(S : string) : string;
  33. {If first char is '@' then removes the '@' and otherwise does nothing--
  34.    assumes string is a variable name.
  35.  else
  36.    Puts single quotes around a string and doubles any internal single quotes}
  37. var
  38.   I : Integer;
  39. begin
  40. I := Pos('@', S);
  41. if I = 1 then
  42.   begin
  43.   Quoted := Copy(S, 2, 255);
  44.   Exit;
  45.   end;
  46. I := Pos('''', S);
  47. while I > 0 do
  48.   begin
  49.   Insert('''', S, I);
  50.   I := Positn('''', S, I+2);
  51.   end;
  52. Insert('''', S, 1);
  53. Quoted := S+'''';
  54. end;
  55.  
  56. procedure RDotAssign(P : PScriptRec);
  57. begin
  58. with P^.MainBlock do
  59.   begin
  60.   WriteLn(Outf, 'R.Assign(', X1, ', ', Y1, ', ', X2,', ', Y2, ');');
  61.   end;
  62. end;
  63.  
  64. procedure DoOpEvent(P : PScriptRec; const Sym : string);
  65. var
  66.   S : string;
  67. begin
  68. with P^.MainBlock do
  69.   begin
  70.   if DefOptns <> Optns then
  71.     begin
  72.     Write(Outf, Sym, '^.Options := ');
  73.     S := OptionStr(Optns, DefOptns, GetOptionWords);
  74.     if S[1] = '$' then
  75.       WriteLn(OutF, S)
  76.     else WriteLn(OutF, Sym, '^.Options', S);
  77.     end;
  78.   if DefEvMsk <> EvMsk then
  79.     begin
  80.     Write(Outf, Sym, '^.EventMask := ');
  81.     S := OptionStr(EvMsk, DefEvMsk, GetEventWords);
  82.     if S[1] = '$' then
  83.       WriteLn(OutF, S)
  84.     else WriteLn(OutF, Sym, '^.EventMask', S);
  85.     end;
  86.   end;
  87. end;
  88.  
  89. PROCEDURE WriteHelpCtx(Rf : PString; H : String; Ctx : word);
  90. Const
  91.   NoContext : String[11] = 'hcNoContext';
  92. begin
  93. if (H = '') and (Ctx > 0) then
  94.    Str(Ctx, H);
  95. if (H <> '') and not SameString(H, NoContext) then
  96.   WriteLn(OutF, Rf^, '^.HelpCtx := ', H, ';' );
  97. end;
  98.  
  99. procedure WriteButton(P : PScriptRec); {write code for TButton}
  100. var
  101.   S : string[55];
  102.  
  103.   function FlagStr : string;
  104.   var
  105.     S : string[55];
  106.   begin
  107.   with P^ do
  108.     begin
  109.     S := '';
  110.     if Flags = 0 then S := 'bfNormal'
  111.     else
  112.       begin
  113.       if Flags and 1 <> 0 then S := 'bfDefault or ';
  114.       if Flags and 2 <> 0 then S := S+'bfLeftJust or ';
  115.       if Flags and 4 <> 0 then S := S+'bfBroadcast or ';
  116.       if Flags and 8 <> 0 then S := S+'bfGrabFocus or ';
  117.       Dec(S[0], 4);  {remove extra ' or '}
  118.       end;
  119.     end;
  120.   FlagStr := S;
  121.   end;
  122.  
  123. begin
  124. with P^, MainBlock do
  125.   begin
  126.   RDotAssign(P);
  127.   if SameString(Obj^, 'POptionButton') then  {a special TOptionButton}
  128.     WriteLn(OutF, VarName^, ' := New(', Obj^, ', Init(R, ', Param[1]^,
  129.          ', '+Param[2]^+'));' )
  130.   else
  131.     begin   {regular button}
  132.     if CommandName^ <> '' then S := CommandName^
  133.       else Str(CommandValue, S);
  134.     Write(OutF, VarName^, ' := New(', Obj^, ', Init(R, ',
  135.          Quoted(ButtonText^), ', '+S+', ' );
  136.     WriteLn(OutF, FlagStr+'));' );
  137.     end;
  138.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  139.   DoOpEvent(P, VarName^);
  140.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  141.   end;
  142. end;
  143.  
  144. procedure WriteInputLong(P : PScriptRec);  {code for TInputLong}
  145. begin
  146. with P^, MainBlock do
  147.   begin
  148.   RDotAssign(P);
  149.   WriteLn(OutF,
  150.          VarName^, ' := New('+Obj^+', Init(R, ', LongStrLeng,
  151.          ', ', LLim, ', ', ULim,  ', ', ILOptions, '));' );
  152.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  153.   DoOpEvent(P, VarName^);
  154.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  155.   end;
  156. end;
  157.  
  158. procedure WriteInputLine(P : PScriptRec); {code for TInputLine}
  159. var
  160.   S : string[15];
  161.  
  162.   function DoubleInsideQuotes(St : string) : string;
  163.   var
  164.     I : integer;
  165.   begin
  166.   I := Pos('''', St);
  167.   while I > 0 do
  168.     begin
  169.     Insert('''', St, I);
  170.     I := Positn('''', St, I+2);
  171.     end;
  172.   DoubleInsideQuotes := St;
  173.   end;
  174.  
  175. begin
  176. with P^, MainBlock do
  177.   begin
  178.   RDotAssign(P);
  179.   WriteLn(OutF,
  180.          VarName^, ' := New('+Obj^+', Init(R, ', StringLeng, '));' );
  181.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  182.   DoOpEvent(P, VarName^);
  183.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  184.  
  185.   if ValKind in [Picture..StringLookup] then
  186.     begin
  187.     Write(OutF, '  ', Obj^+'('+VarName^+')^.Validator := New(', ValPtrName^,
  188.         ', Init(');
  189.     case ValKind of
  190.       Picture:
  191.          begin
  192.          if AutoFill <> 0 then S := 'True' else S := 'False';
  193.          {Note: PictureString may start with '@'}
  194.          WriteLn(OutF, '''', DoubleInsideQuotes(PictureString^), ''', ', S, '));');
  195.          end;
  196.       Range:
  197.          begin
  198.          WriteLn(OutF, LowLim, ', ', UpLim, '));');
  199.          if Transfer <> 0 then
  200.            WriteLn(OutF, '  ',
  201.                Obj^+'('+VarName^+')^.Validator^.Options := voTransfer;');
  202.          end;
  203.       Filter:
  204.          WriteLn(OutF, CharSet^, '));');
  205.       StringLookup:
  206.          WriteLn(OutF, List^, '));');
  207.       end;
  208.     end;
  209.   end;
  210. end;
  211.  
  212. procedure WriteMemo(P : PScriptRec);
  213. begin
  214. with P^, MainBlock do
  215.   begin
  216.   RDotAssign(P);
  217.   Write(OutF,
  218.          VarName^, ' := New('+Obj^+', Init(R, ');
  219.   if HScroll^ <> '' then
  220.     Write(OutF, 'PScrollbar(Control1), ')
  221.   else Write(OutF, 'Nil, ' );
  222.   if VScroll^ <> '' then
  223.     Write(OutF, 'PScrollbar(Control), ')
  224.   else Write(OutF, 'Nil, ' );
  225.   WriteLn(OutF, 'Nil, ', BufSize, '));');
  226.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  227.   DoOpEvent(P, VarName^);
  228.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  229.   end;
  230. end;
  231.  
  232. procedure WriteListBox(P : PScriptRec);
  233. begin
  234. with P^, MainBlock do
  235.   begin
  236.   RDotAssign(P);
  237.   Write(OutF,
  238.          VarName^, ' := New('+Obj^+', Init(R, ', Columns);
  239.   if Scrollbar^ <> '' then
  240.     WriteLn(OutF, ', PScrollbar('+ScrollBar^+')));')
  241.   else WriteLn(OutF, ', Nil));' );
  242.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  243.   DoOpEvent(P, VarName^);
  244.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  245.   end;
  246. end;
  247.  
  248. procedure WriteScrollBar(P : PScriptRec);
  249. begin
  250. with P^, MainBlock do
  251.   begin
  252.   RDotAssign(P);
  253.   WriteLn(OutF,
  254.          VarName^, ' := New('+Obj^+', Init(R));');
  255.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  256.   DoOpEvent(P, VarName^);
  257.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  258.   end;
  259. end;
  260.  
  261. procedure WriteCheckRadio(P : PScriptRec);
  262. var
  263.   I : integer;
  264.  
  265.   function MCBFlagString(Flags : word) : string;
  266.   var
  267.     S : string[30];
  268.   begin
  269.   if Flags = $101 then S := 'cfOneBit'
  270.   else if Flags = $203 then S := 'cfTwoBits'
  271.   else if Flags = $40F then S := 'cfFourBits'
  272.   else if Flags = $8FF then S := 'cfEightBits'
  273.   else S := '$'+Hex4(Flags);
  274.   MCBFlagString := S;
  275.   end;
  276.  
  277. begin
  278. with P^, MainBlock do
  279.   begin
  280.   RDotAssign(P);
  281.   Write(OutF,
  282.          VarName^, ' := New('+Obj^+', Init(R, ');
  283.   for I := 0 to Items-1 do
  284.     Write(OutF, ^M^J'  NewSItem(', Quoted(PString(LabelColl^.At(I))^), ',');
  285.   Write(OutF, ' Nil)');
  286.   for I := 1 to Items-1 do
  287.     Write(OutF, ')');
  288.   if Kind = MultiCB then
  289.     Write(OutF, ', ', SelRange, ', ', MCBFlagString(MCBFlags), ', ', Quoted(States^));
  290.   WriteLn(OutF, '));');
  291.   if Mask <> -1 then
  292.     WriteLn(OutF, 'PCluster('+VarName^+')^.SetButtonState($', Hex8(not Mask), ', False);');
  293.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  294.   DoOpEvent(P, VarName^);
  295.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  296.   end;
  297. end;
  298.  
  299. procedure WriteHistory(P : PScriptRec);
  300. begin
  301. with P^, MainBlock do
  302.   begin
  303.   Write(OutF, '  ');
  304.   RDotAssign(P);
  305.   WriteLn(OutF, '  ', DlgName, '^.Insert(New(PHistory, Init(R, PInputline(',
  306.                     HistoryLink^, '), ', HistoryID, ')));');
  307.   end;
  308. end;
  309.  
  310. procedure WriteStaticText(P : PScriptRec);
  311.   procedure DoAtText;
  312.   var
  313.     S : string;
  314.     I : integer;
  315.   begin
  316.   S := P^.Text^;
  317.   I := Pos(^C, S);
  318.   while I > 0 do
  319.     begin
  320.     Delete(S, I, 1);  {remove ^C's}
  321.     I := Pos(^C, S);
  322.     end;
  323.   Delete(S, 1, 1);   {remove '@'}
  324.   I := Pos(^M, S);
  325.   while I > 0 do
  326.     begin
  327.     Delete(S, I, 1);  {remove ^M's}
  328.     I := Pos(^M, S);
  329.     end;
  330.   Write(OutF, S);
  331.   end;
  332.  
  333.   procedure DoText;  {split Text into short lines if it is long}
  334.                      {convert single quotes to double}
  335.   var
  336.     I, Count, TextLeng : Integer;
  337.     Ch : char;
  338.     S : string[20];
  339.   begin
  340.   Write(OutF, '''');
  341.   Count := 38;
  342.   with P^ do
  343.     begin
  344.     I := 1;
  345.     TextLeng := Length(Text^);
  346.     while I <= TextLeng do
  347.       begin
  348.       Ch := Text^[I];
  349.       if Ch = ^M then
  350.          begin
  351.          if I >= TextLeng then
  352.             S := ''    {on the end}
  353.          else S := '''^M+'^M^J'     ''';
  354.          Count := 0;
  355.          end
  356.       else if Ch = '''' then
  357.          S := ''''''    {one quote to two}
  358.       else S := Ch;
  359.       Write(OutF, S);
  360.       Inc(Count, Length(S));
  361.       if (Count >= 75) and (I < TextLeng) then
  362.         begin
  363.         Write(OutF, '''+'^M^J'     ''');
  364.         Count := 5;
  365.         end;
  366.       Inc(I);
  367.       end;
  368.     end;
  369.   Write(OutF, '''');
  370.   end;
  371.  
  372. begin
  373. with P^, MainBlock do
  374.   begin
  375.   RDotAssign(P);
  376.   Write(OutF, VarName^, ' := New('+Obj^+', Init(R, ');
  377.   if (Length(Text^) > 1) and ((Text^[1] = '@')
  378.          or (Text^[2] = '@')) then    {could be ^C'@'}
  379.     DoAtText
  380.   else
  381.     DoText;
  382.   if Kind = SText then
  383.     WriteLn(OutF, '));')
  384.   else
  385.     WriteLn(OutF, ', $', Hex2(Byte(Attrib)), '));');
  386.   DoOpEvent(P, VarName^);
  387.   WriteLn(OutF, DlgName, '^.Insert(', VarName^, ');');
  388.   end;
  389. end;
  390.  
  391. procedure WriteLabel(P : PScriptRec);
  392. begin
  393. with P^, MainBlock do
  394.   begin
  395.   Write(OutF, '  ');
  396.   RDotAssign(P);
  397.   WriteLn(OutF, '  ', DlgName, '^.Insert(New('+Obj^+', Init(R, '+
  398.           Quoted(LabelText^)+', ', LinkName^, ')));' );
  399.   end;
  400. end;
  401.  
  402. procedure WriteSource;
  403. var
  404.   First : boolean;
  405.   S : string[30];
  406.   I : integer;
  407.  
  408.   procedure DoControls(P : PScriptRec); far;
  409.   begin
  410.   case P^.Kind of
  411.     Button: WriteButton(P);
  412.     InputL: WriteInputLine(P);
  413.     Labl: WriteLabel(P);
  414.     Histry: WriteHistory(P);
  415.     ILong: WriteInputLong(P);
  416.     CheckB, RadioB, MultiCB:
  417.            WriteCheckRadio(P);
  418.     ListB: WriteListBox(P);
  419.     ScrollB: WriteScrollBar(P);
  420.     Memo:  WriteMemo(P);
  421.     CText, SText: WriteStaticText(P);
  422.     end;
  423.   WriteLn(OutF);
  424.   end;
  425.  
  426.   procedure DoVars(P : PScriptRec); far;
  427.   begin
  428.   with P^, MainBlock do
  429.     if (VarName^ <> '') and not SameString(VarName^, 'Control')
  430.         and not SameString(VarName^, 'Control1') then
  431.       WriteLn(OutF, '  ', VarName^, ' : ', Obj^, ';');
  432.   end;
  433.  
  434.   procedure DoFields(P : PScriptRec); far;
  435.   var
  436.     S : string[15];
  437.  
  438.     procedure ChkFirst;
  439.     begin
  440.     if First then  {at least one fieldname to output}
  441.       begin
  442.       WriteLn(OutF, 'var'^M^J'  ', Dialog^.MainBlock.FieldName^, ' : record');
  443.       First := False;
  444.       end;
  445.     end;
  446.  
  447.   begin
  448.   with P^, MainBlock do
  449.     if FieldName^ <> '' then
  450.       begin
  451.       ChkFirst;
  452.       Write(OutF, '    ', FieldName^);
  453.       case Kind of
  454.         CheckB, RadioB :
  455.            WriteLn(OutF, ' : Word;');
  456.         MultiCB, ILong :
  457.            WriteLn(OutF, ' : LongInt;');
  458.         InputL :
  459.           begin
  460.           if (ValKind = Range) and (Transfer <> 0) then
  461.              WriteLn(OutF, ' : LongInt;')
  462.           else
  463.             begin
  464.             Str(StringLeng, S);
  465.             WriteLn(OutF, ' : String['+S+'];');
  466.             end;
  467.           end;
  468.         ListB :
  469.           WriteLn(OutF, ' : TListBoxRec;');
  470.         Memo :
  471.           begin
  472.           WriteLn(OutF, ' : Word;');
  473.           Str(BufSize, S);
  474.           WriteLn(OutF, '    ', TextFieldName^, ' : Array[1..'+S+'] of Char;');
  475.           NeedControl1 := NeedControl1 or (HScroll^ <> '');
  476.           end;
  477.         end;
  478.       end
  479.     else if SameString(Obj^, 'POptionButton') then
  480.       begin            {it's a special, fieldname is in parameter 3}
  481.       ChkFirst;
  482.       WriteLn(OutF, '    ', Param[3]^, ' : OptionRec;');
  483.       end;
  484.   end;
  485.  
  486. begin
  487. with Dialog^, MainBlock do
  488.   begin
  489.   DlgName := VarName^;
  490.  
  491.   if FieldName^ <> '' then   {No fieldname, no DataRec}
  492.     begin
  493.     if Present[ListB] then
  494.       WriteLn(OutF, 'type'^M^J+
  495.        '  TListBoxRec = record    {<-- omit if TListBoxRec is defined elsewhere}'^M^J+
  496.        '    PS : PStringCollection;'^M^J+
  497.        '    Selection : Integer;'^M^J+
  498.        '    end;'^M^J);
  499.  
  500.     First := True;
  501.     ScriptColl^.ForEach(@DoFields);
  502.     if not First then   {if First still set, there is no data record}
  503.       WriteLn(OutF, '  end;'^M^J);
  504.     end;
  505.  
  506.   WriteLn(Outf, 'function ', DlgFuncName^, ' : ', Obj^, ';');
  507.   Write(Outf, 'var'^M^J'  ', DlgName, ' : ', Obj^, ';'^M^J'  R : TRect;'^M^J'  '+
  508.              'Control');
  509.   if NeedControl1 then
  510.     WriteLn(OutF, ', Control1 : PView;')
  511.   else WriteLn(OutF, ' : PView;');
  512.  
  513.   ScriptColl^.ForEach(@DoVars);
  514.  
  515.   WriteLn(OutF, ^M^J'begin');
  516.   RDotAssign(Dialog);
  517.   WriteLn(Outf, 'New(', DlgName, ', Init(R, ', Quoted(Title^), '));');
  518.   DoOpEvent(Dialog, DlgName);
  519.   WriteHelpCtx(VarName, HelpCtxSym^, HCtx);
  520.   if Palette <> dpGrayDialog then
  521.     begin
  522.     if Palette = dpBlueDialog then S := 'dpBlueDialog'
  523.       else S := 'dpCyanDialog';
  524.     WriteLn(Outf, VarName^, '^.Palette := ', S, ';');
  525.     end;
  526.  
  527.   if WinFlags <> 5 then
  528.     WriteLn(Outf, VarName^, '^.Flags := ', VarName^, '^.Flags',
  529.                   OptionStr(WinFlags, 5, GetWinFlagWords));
  530.   WriteLn(OutF);
  531.  
  532.   ScriptColl^.ForEach(@DoControls);   {all the controls in dialog}
  533.  
  534.   S := DlgFuncName^;
  535.   I := Pos('.', S);  {remove 'TMyApp.' from 'TMyApp.MakeDialog'}
  536.   if I > 0 then Delete(S, 1, I);
  537.   WriteLn(Outf, DlgName, '^.SelectNext(False);'^M^J, S, ' := ',
  538.                 DlgName, ';'^M^J'end;');
  539.   end;
  540. end;
  541.  
  542.  
  543. function HeapFunc(Size : word) : integer; far;
  544. begin
  545. if Size > 0 then
  546.   begin
  547.   WriteLn('Out of memory');
  548.   Halt(1);
  549.   end;
  550. end;
  551.  
  552. begin
  553. HeapError := @HeapFunc;
  554.  
  555. if ParamCount < 2 then
  556.   begin
  557.   WriteLn('Usage:  passrc1 <script filename> <source filename> [error filename]');
  558.   Halt(1);
  559.   end;
  560. if ParamCount >= 3 then
  561.   begin   {redirect output to error file}
  562.   Assign(OutPut, ParamStr(3));   {the error file}
  563.   ReWrite(Output);
  564.   end;
  565. {$I-}
  566.  
  567. ReadScriptFile( DefaultExt (ParamStr(1), '.SCP'));  {ParamStr(1) is script file}
  568.  
  569. Assign(OutF, DefaultExt (ParamStr(2), '.SRC'));    {ParamStr(2) is output source file}
  570. Rewrite(OutF);
  571. ChkIOError(DefaultExt (ParamStr(2), '.SRC'));
  572.  
  573. WriteSource;
  574. Close(Outf);
  575. end.
  576.